home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / gscm.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-16  |  28.0 KB  |  1,466 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43.  
  44.  
  45. #include <stdio.h>
  46. #include <sys/param.h>
  47. #include "gscm.h"
  48. #include "_scm.h"
  49.  
  50.  
  51.  
  52. void scm_init_guile ();
  53. static char version_string[] = "GNU Guile, version iii";
  54.  
  55.  
  56. /* {Object Id's}
  57.  *
  58.  * An id is a name for an object.  By this interface, ids are explicitly
  59.  * allocated and freed.  Any object can have any number of ids.
  60.  * while an id is allocated, it protects the object to which it belongs.
  61.  */
  62.  
  63. static SCM * indirects = 0;
  64. static int free_indirect;
  65. static SCM n_indirects;  /* Used as a C integer type...not as an SCM object */
  66.  
  67. #ifdef __STDC__
  68. long
  69. gscm_mk_objid (SCM obj)
  70. #else
  71. long
  72. gscm_mk_objid (obj)
  73.      SCM obj;
  74. #endif
  75. {
  76.   if (indirects == 0)
  77.     {
  78.       DEFER_INTS;
  79.       indirects = scm_mkarray (256, 0);
  80.       if (!indirects)
  81.     {
  82.       ALLOW_INTS;
  83.       return -1;
  84.     }
  85.       n_indirects = 256;
  86.       {
  87.     int x;
  88.     for (x = 0; x < 256; ++x)
  89.       indirects[x] = MAKINUM (x + 1);
  90.     free_indirect = 0;
  91.     n_indirects = 256;
  92.       }
  93.       ALLOW_INTS;
  94.     }
  95.  
  96.   if (free_indirect == n_indirects)
  97.     {
  98.       /* This sucks: */
  99.       if ((2 * n_indirects) > MOST_POSITIVE_FIXNUM)
  100.     return -1;
  101.       {
  102.     SCM * new_indirects;
  103.     DEFER_INTS;
  104.     new_indirects = scm_mkarray (2 * n_indirects, 0);
  105.     if (!new_indirects)
  106.       return -1;
  107.     scm_free_array (indirects);
  108.     indirects = new_indirects;
  109.     {
  110.       int x;
  111.       x = n_indirects;
  112.       n_indirects *= 2;
  113.       while (x < n_indirects)
  114.         indirects[x] = MAKINUM (x + 1);
  115.  
  116.  
  117.       bcopy (indirects, new_indirects, 2 * n_indirects);
  118.     }
  119.     ALLOW_INTS;
  120.       }
  121.     }
  122.   {
  123.     int id;
  124.     id = free_indirect;
  125.     free_indirect = INUM (indirects[id]);
  126.     indirects[id] = obj;
  127.     return id;
  128.   }
  129. }
  130.  
  131. #ifdef __STDC__
  132. SCM
  133. gscm_id2obj (long n)
  134. #else
  135. SCM
  136. gscm_id2obj (n)
  137.      long n;
  138. #endif
  139. {
  140.   return indirects[n];
  141. }
  142.  
  143. #ifdef __STDC__
  144. void
  145. gscm_free_id (long n)
  146. #else
  147. void
  148. gscm_free_id (n)
  149.      long n;
  150. #endif
  151. {
  152.   indirects[n] = MAKINUM (free_indirect);
  153.   free_indirect = n;
  154. }
  155.  
  156. #ifdef __STDC__
  157. void
  158. gscm_id_reassign (long n, SCM obj)
  159. #else
  160. void
  161. gscm_id_reassign (n, obj)
  162.      long n;
  163.      SCM obj;
  164. #endif
  165. {
  166.   indirects[n] = obj;
  167. }
  168.  
  169. PROC (s_sys_id, "%id", 1, 0, 0, gscm_sys_id);
  170. #ifdef __STDC__
  171. SCM
  172. gscm_sys_id(SCM n)
  173. #else
  174. SCM
  175. gscm_sys_id (n)
  176.      SCM n;
  177. #endif
  178. {
  179.   int cn;
  180.   ASSERT (INUMP (n), n, ARG1, s_sys_id);
  181.   cn = INUM (n);
  182.   ASSERT (!((cn >= n_indirects) || (cn < 0)), n, OUTOFRANGE, s_sys_id);
  183.   return indirects [n];
  184. }
  185.  
  186.  
  187.  
  188. extern int scm_verbose;
  189. int gscm_default_verbosity = 2;
  190.  
  191.  
  192. PROC (s_sys_default_verbosity, "%default-verbosity", 0, 0, 0, gscm_sys_default_verbosity);
  193. #ifdef __STDC__
  194. SCM 
  195. gscm_sys_default_verbosity (void)
  196. #else
  197. SCM 
  198. gscm_dflt_verbosity ()
  199. #endif
  200. {
  201.   return MAKINUM (gscm_default_verbosity);
  202. }
  203.  
  204.  
  205. #ifdef __STDC__
  206. void
  207. gscm_verbosity (int n)
  208. #else
  209. void
  210. gscm_verbosity (n)
  211.      int n;
  212. #endif
  213. {
  214.  
  215.   gscm_default_verbosity = n;
  216. }
  217.  
  218. #ifdef __STDC__
  219. void
  220. gscm_with_verbosity (int n, void (*fn)P((void *)), void * data)
  221. #else
  222. void
  223. gscm_with_verbosity (n, fn, data)
  224.      int n;
  225.      void (*fn)P((void *));
  226.      void * data;
  227. #endif
  228. {
  229.   int oldv;
  230.   oldv = scm_verbose;
  231.   scm_verbose = n;
  232.   fn (data);
  233.   scm_verbose = oldv;
  234. }
  235.  
  236.  
  237. /* {Initialization}
  238.  */
  239.  
  240.  
  241. /* Normally the default heap size is used (indicated by
  242.  * passing 0 to scm_init_scm).  But applications can override 
  243.  * this if they need to.
  244.  */
  245.  
  246. static char init_file_name[MAXPATHLEN];
  247. static int init_file_processed = 0;
  248.  
  249.  
  250. static int init_heap_size = 0;  /* in units of 1024 bytes. */
  251. #ifdef __STDC__
  252. void
  253. gscm_set_init_heap_size (int x)
  254. #else
  255. void
  256. gscm_set_init_heap_size (x)
  257.      int x;
  258. #endif
  259. {
  260.   init_heap_size = x;
  261. }
  262.  
  263. #ifdef __STDC__
  264. int
  265. gscm_init_heap_size (void)
  266. #else
  267. int
  268. gscm_init_heap_size ()
  269. #endif
  270. {
  271.   return init_heap_size;
  272. }
  273. extern SCM *scm_loc_tick_signal;
  274.  
  275. char *getenv ();
  276. char * gscm_last_attempted_init_file = "<none>";
  277.  
  278. #ifdef __STDC__
  279. GSCM_status
  280. gscm_init_from_fn (char *initfile, int argc, char **argv, void (*init_fn) ())
  281. #else
  282. GSCM_status
  283. gscm_init_from_fn (initfile, argc, argv, init_fn)
  284.      char *initfile;
  285.      int argc;
  286.      char **argv;
  287.      void (*init_fn) ();
  288. #endif
  289. {
  290.   /* Init all the built-in parts of SCM. */
  291. /*  scm_init_scm (scm_verbose, init_heap_size); */
  292.  
  293.   /* Save the argument list to be the return value of (program-arguments).
  294.    */
  295.   progargs = scm_makfromstrs (argc, argv);
  296.  
  297.   scm_exitval = MAKINUM (EXIT_SUCCESS);
  298.   scm_errjmp_bad = 0;
  299.   errno = 0;
  300.   scm_alrm_deferred = 0;
  301.   scm_sig_deferred = 0;
  302.   scm_ints_disabled = 1;
  303.  
  304. #if 0
  305. /* !!! */
  306. #ifdef SIGALRM
  307.   scm_make_subr (s_alarm, tc7_subr_1, "alarm");
  308. #ifndef AMIGA
  309.   scm_make_subr ("pause", tc7_subr_0, "pause");
  310. #endif
  311. #endif
  312.  
  313. #ifndef AMIGA
  314.   scm_make_subr ("sleep", tc7_subr_1, "sleep");
  315. #endif
  316.  
  317.   scm_make_subr ("raise", tc7_subr_1, "raise");
  318.   
  319. #ifdef TICKS
  320.   scm_loc_tick_signal = &CDR (scm_sysintern ("ticks-interrupt", SCM_UNDEFINED));
  321.   scm_make_subr ("ticks", tc7_subr_1o, "ticks");
  322. #endif
  323. #endif
  324.   scm_init_variable();
  325.   scm_init_gsubr();
  326.   scm_init_kw();
  327.   init_fn ();    /* call initialization of extensions files */
  328. #ifdef DLD
  329.   init_dynl ();
  330. #else
  331. #ifdef SUN_DL
  332.   init_dynl ();
  333. #endif
  334. #endif
  335.  
  336.   if (initfile == NULL)
  337.     {
  338.       initfile = getenv ("GUILE_INIT_PATH");
  339.       if (initfile == NULL)
  340.     initfile = IMPLINIT;
  341.     }
  342.  
  343.   if (initfile == NULL)
  344.     {
  345.       init_file_processed = 1;
  346.       return GSCM_OK;
  347.     }
  348.   else
  349.     {
  350.       int verb;
  351.       GSCM_status status;
  352.       SCM answer;
  353.  
  354.       gscm_last_attempted_init_file = initfile;
  355.       verb = scm_verbose;
  356.       scm_verbose = -1;
  357.       init_file_processed = 0;
  358.       strncpy (init_file_name, initfile, MAXPATHLEN);
  359.       status = gscm_seval_file (&answer, -1, initfile);
  360.       if ((status == GSCM_OK) && (answer == BOOL_F))
  361.     status = GSCM_ERROR_OPENING_INIT_FILE;
  362.       scm_verbose = verb;
  363.       return status;
  364.     }
  365. }
  366.  
  367. #ifdef __STDC__
  368. void
  369. gscm_take_stdin (void)
  370. #else
  371. void
  372. gscm_take_stdin ()
  373. #endif
  374. {
  375.  
  376.   if (isatty(fileno(stdin))) setbuf(stdin, 0); /* turn off stdin buffering */
  377.   scm_take_stdin = 1;
  378. }
  379.  
  380. #ifdef __STDC__
  381. void
  382. gscm_verbose (int n)
  383. #else
  384. void
  385. gscm_verbose (n)
  386.      int n;
  387. #endif
  388. {
  389.   scm_verbose = n;
  390. }
  391.  
  392.  
  393.  
  394.  
  395. /* {Managing Top Levels}
  396.  */
  397.  
  398. struct seval_str_frame
  399. {
  400.   GSCM_status status;
  401.   SCM * answer;
  402.   GSCM_top_level top;
  403.   char * str;
  404. };
  405.  
  406. #ifdef __STDC__
  407. static void
  408. _seval_str_fn (void * vframe)
  409. #else
  410. static void
  411. _seval_str_fn (vframe)
  412.      void * vframe;
  413. #endif
  414. {
  415.   struct seval_str_frame * frame;
  416.   frame = (struct seval_str_frame *)vframe;
  417.   frame->status = gscm_seval_str (frame->answer, frame->top, frame->str);
  418. }
  419.  
  420.  
  421. #ifdef __STDC__
  422. GSCM_status
  423. gscm_create_top_level (GSCM_top_level * answer)
  424. #else
  425. GSCM_status
  426. gscm_create_top_level (answer)
  427.      GSCM_top_level * answer;
  428. #endif
  429. {
  430.   SCM it;
  431.   GSCM_status stat;
  432.   struct seval_str_frame frame;
  433.  
  434.   frame.str = "(gscm-create-top-level)";
  435.   frame.top = -1;
  436.   frame.answer = ⁢
  437.   gscm_with_verbosity (-1, _seval_str_fn, &frame);
  438.   stat = frame.status;
  439.   if (stat == GSCM_OK)
  440.     *answer = (GSCM_top_level)gscm_mk_objid (it);
  441.   return stat;
  442. }
  443.  
  444. #ifdef __STDC__
  445. GSCM_status
  446. gscm_destroy_top_level (GSCM_top_level it)
  447. #else
  448. GSCM_status
  449. gscm_destroy_top_level (it)
  450.      GSCM_top_level it;
  451. #endif
  452. {
  453.   char buf[300];
  454.   GSCM_status stat;
  455.   struct seval_str_frame frame;
  456.  
  457.   sprintf (buf, "(gscm-destroy-top-level (\%\%gscm-indirect %d))", it);
  458.   frame.str = buf;
  459.   frame.top = -1;
  460.   frame.answer = 0;
  461.   gscm_with_verbosity (-1, _seval_str_fn, &frame);
  462.   stat = frame.status;
  463.   return stat;
  464. }
  465.  
  466.  
  467. /* {Top Level Evaluation}
  468.  * 
  469.  * Top level evaluation has to establish a dynamic root context,
  470.  * enable Scheme signal handlers, and catch global escapes (errors, quits,
  471.  * aborts, restarts, and execs) from the interpreter.
  472.  */
  473.  
  474. extern unsigned int scm_tick_count;
  475. extern unsigned int scm_ticken;
  476.  
  477.  
  478. /* {Printing Objects to Strings} 
  479.  */
  480.  
  481. #ifdef __STDC__
  482. static GSCM_status
  483. gscm_portprint_obj (SCM port, SCM obj)
  484. #else
  485. static GSCM_status
  486. gscm_portprint_obj (port, obj)
  487.      SCM port;
  488.      SCM obj;
  489. #endif
  490. {
  491.   scm_iprin1 (obj, port, 1);
  492.   return GSCM_OK;
  493. }
  494.  
  495. #ifdef __STDC__
  496. static GSCM_status
  497. gscm_strprint_obj (SCM * answer, SCM obj)
  498. #else
  499. static GSCM_status
  500. gscm_strprint_obj (answer, obj)
  501.      SCM * answer;
  502.      SCM obj;
  503. #endif
  504. {
  505.   SCM str;
  506.   SCM port;
  507.   GSCM_status stat;
  508.   str = scm_makstr (64, 0);
  509.   port = scm_mkstrport (MAKINUM (0), str, OPN | WRTNG, "gscm_strprint_obj");
  510.   stat = gscm_portprint_obj (port, obj);
  511.   if (stat == GSCM_OK)
  512.     *answer = str;
  513.   else
  514.     *answer = BOOL_F;
  515.   return stat;
  516. }
  517.  
  518. #ifdef __STDC__
  519. static GSCM_status
  520. gscm_cstr (char ** answer, SCM obj)
  521. #else
  522. static GSCM_status
  523. gscm_cstr (answer, obj)
  524.      char ** answer;
  525.      SCM obj;
  526. #endif
  527. {
  528.   SCM sstr;
  529.   GSCM_status stat;
  530.  
  531.   *answer = (char *)malloc (LENGTH (sstr));
  532.   stat = GSCM_OK;
  533.   if (!*answer)
  534.     stat = GSCM_OUT_OF_MEM;
  535.   else
  536.     bcopy (CHARS (sstr), *answer, LENGTH (sstr));
  537.   return stat;
  538. }
  539.      
  540.  
  541. /* {Invoking The Interpreter}
  542.  */
  543.  
  544. #ifdef _UNICOS
  545. typedef int setjmp_type;
  546. #else
  547. typedef long setjmp_type;
  548. #endif
  549.  
  550. extern SCM *scm_loc_loadpath;
  551. extern long scm_linum;
  552.  
  553. #ifdef __STDC__
  554. static GSCM_status
  555. _eval_port (SCM * answer, GSCM_top_level toplvl, SCM port, int printp)
  556. #else
  557. static GSCM_status
  558. _eval_port (answer, toplvl, port, printp)
  559.      SCM * answer;
  560.      GSCM_top_level toplvl;
  561.      SCM port;
  562.      int printp;
  563. #endif
  564. {
  565.   SCM saved_inp;
  566.   GSCM_status status;
  567.   setjmp_type i;
  568.   static int deja_vu = 0;
  569.   SCM ignored;
  570.  
  571.   if (deja_vu)
  572.     return GSCM_ILLEGALLY_REENTERED;
  573.  
  574.   ++deja_vu;
  575.   /* Take over signal handlers for all the interesting signals.
  576.    */
  577.   scm_init_signals ();
  578.  
  579.  
  580.   /* Default return values:
  581.    */
  582.   if (!answer)
  583.     answer = &ignored;
  584.   status = GSCM_OK;
  585.   *answer = BOOL_F;
  586.  
  587.   /* Perform evalutation under a new dynamic root.
  588.    *
  589.    */
  590.   BASE (rootcont) = (STACKITEM *) & i;
  591.   saved_inp = cur_inp;
  592.   i = setjmp (JMPBUF (rootcont));
  593.   cur_inp = saved_inp;
  594.  drloop:
  595.   switch ((int) i)
  596.     {
  597.     default:
  598.       {
  599.     char *name;
  600.     name = scm_errmsgs[i - WNA].s_response;
  601.     if (name)
  602.       {
  603.         SCM proc;
  604.         proc = CDR (scm_intern (name, (sizet) strlen (name)));
  605.         if (NIMP (proc))
  606.           scm_apply (proc, EOL, EOL);
  607.       }
  608.     if ((i = scm_errmsgs[i - WNA].parent_err))
  609.       goto drloop;
  610.     def_err_response ();
  611.     goto leave;
  612.       }
  613.  
  614.     case 0:
  615.       scm_exitval = MAKINUM (EXIT_SUCCESS);
  616.       scm_errjmp_bad = 0;
  617.       errno = 0;
  618.       scm_alrm_deferred = 0;
  619.       scm_sig_deferred = 0;
  620.       scm_ints_disabled = 0;
  621.  
  622.     case -2:
  623.       scm_alrm_deferred = 0;
  624.       scm_sig_deferred = 0;
  625.       scm_errjmp_bad = 0;
  626.       scm_ints_disabled = 0;
  627.       /* need to close loading files here. */
  628.       cur_inp = port;
  629.       *scm_loc_loadpath = BOOL_F;
  630.  
  631.       {
  632.     SCM top_env;
  633.     top_env = (toplvl == -1
  634.            ? EOL
  635.            : gscm_id2obj (toplvl));
  636.     *answer = scm_repl (nullstr, top_env);
  637.       }
  638.       cur_inp = saved_inp;
  639.       if (printp)
  640.     status = gscm_strprint_obj (answer, *answer);
  641.       goto return_fixing_signals;
  642.  
  643.     case -1:
  644.       status = GSCM_QUIT;
  645.       goto leave;
  646.  
  647.     case -3:
  648.       status = GSCM_RESTART;
  649.       goto leave;
  650.     }
  651.  leave:
  652.   scm_alrm_deferred = 0;
  653.   scm_sig_deferred = 0;
  654.  
  655.  return_fixing_signals:
  656.   scm_errjmp_bad = 1;
  657.   scm_ints_disabled = 1;
  658.   scm_restore_signals ();
  659. #ifdef TICKS
  660.   scm_ticken = 0;
  661. #endif
  662.   --deja_vu;
  663.   return status;
  664. }
  665.  
  666. #ifdef __STDC__
  667. static GSCM_status
  668. seval_str (SCM *answer, GSCM_top_level toplvl, char * str)
  669. #else
  670. static GSCM_status
  671. seval_str (answer, toplvl, str)
  672.      SCM *answer;
  673.      GSCM_top_level toplvl;
  674.      char * str;
  675. #endif
  676. {
  677.   SCM scheme_str;
  678.   SCM port;
  679.   SCM oloadpath;
  680.   long olninum;
  681.   GSCM_status status;
  682.  
  683.   oloadpath = *scm_loc_loadpath;
  684.   olninum = scm_linum;
  685.   scheme_str = scm_makfromstr (str, strlen (str), 0);
  686.   *scm_loc_loadpath = makfrom0str ("(no input file)");
  687.   scm_linum = 1;
  688.   port = scm_mkstrport (MAKINUM (0), scheme_str, OPN | RDNG, "gscm_seval_str");
  689.   status = _eval_port (answer, toplvl, port, 0);
  690.   scm_linum = olninum;
  691.   *scm_loc_loadpath = oloadpath;
  692.   return status;
  693. }
  694.  
  695.  
  696. extern STACKITEM * scm_stack_base;
  697.  
  698. #ifdef __STDC__
  699. GSCM_status
  700. gscm_seval_str (SCM *answer, GSCM_top_level toplvl, char * str)
  701. #else
  702. GSCM_status
  703. gscm_seval_str (answer, toplvl, str)
  704.      SCM *answer;
  705.      GSCM_top_level toplvl;
  706.      char * str;
  707. #endif
  708. {
  709.   STACKITEM i;
  710.   GSCM_status status;
  711.   scm_stack_base = &i;
  712.   status = seval_str (answer, toplvl, str);
  713.   scm_stack_base = 0;
  714.   return status;
  715. }
  716.  
  717. #ifdef __STDC__
  718. void
  719. format_load_command (char * buf, char *file_name)
  720. #else
  721. void
  722. format_load_command (buf, file_name)
  723.      char * buf;
  724.      char *file_name;
  725. #endif
  726. {
  727.   char quoted_name[MAXPATHLEN + 1];
  728.   int source;
  729.   int dest;
  730.  
  731.   for (source = dest = 0; file_name[source]; ++source)
  732.     {
  733.       if (file_name[source] == '"')
  734.     quoted_name[dest++] = '\\';
  735.       quoted_name[dest++] = file_name[source];
  736.     }
  737.   quoted_name[dest] = 0;
  738.   sprintf (buf, "(try-load \"%s\")", quoted_name);
  739. }
  740.  
  741. #ifdef __STDC__
  742. GSCM_status
  743. gscm_seval_file (SCM *answer, GSCM_top_level toplvl, char * file_name)
  744. #else
  745. GSCM_status
  746. gscm_seval_file (answer, toplvl, file_name)
  747.      SCM *answer;
  748.      GSCM_top_level toplvl;
  749.      char * file_name;
  750. #endif
  751. {
  752.   char command[MAXPATHLEN * 3];
  753.   format_load_command (command, file_name);
  754.   return gscm_seval_str (answer, toplvl, command);
  755. }
  756.  
  757.  
  758. #ifdef __STDC__
  759. static GSCM_status
  760. eval_str (char ** answer, GSCM_top_level toplvl, char * str)
  761. #else
  762. static GSCM_status
  763. eval_str (answer, toplvl, str)
  764.      char ** answer;
  765.      GSCM_top_level toplvl;
  766.      char * str;
  767. #endif
  768. {
  769.   SCM sanswer;
  770.   SCM scheme_str;
  771.   SCM port;
  772.   GSCM_status status;
  773.   SCM oloadpath;
  774.   long olninum;
  775.  
  776.   oloadpath = *scm_loc_loadpath;
  777.   olninum = scm_linum;
  778.   scheme_str = scm_makfromstr (str, strlen (str), 0);
  779.   *scm_loc_loadpath = makfrom0str ("(no input file)");
  780.   scm_linum = 1;
  781.   port = scm_mkstrport (MAKINUM(0), scheme_str, OPN | RDNG, "gscm_eval_str");
  782.   status = _eval_port (&sanswer, toplvl, port, 1);
  783.   if (answer)
  784.     {
  785.       if (status == GSCM_OK)
  786.     status = gscm_cstr (answer, sanswer);
  787.       else
  788.     *answer = 0;
  789.     }
  790.   scm_linum = olninum;
  791.   *scm_loc_loadpath = oloadpath;
  792.   return status;
  793. }
  794.  
  795.  
  796. #ifdef __STDC__
  797. GSCM_status
  798. gscm_eval_str (char ** answer, GSCM_top_level toplvl, char * str)
  799. #else
  800. GSCM_status
  801. gscm_eval_str (answer, toplvl, str)
  802.      char ** answer;
  803.      GSCM_top_level toplvl;
  804.      char * str;
  805. #endif
  806. {
  807.   STACKITEM i;
  808.   GSCM_status status;
  809.   scm_stack_base = &i;
  810.   status = eval_str (answer, toplvl, str);
  811.   scm_stack_base = 0;
  812.   return status;
  813. }
  814.  
  815.  
  816. #ifdef __STDC__
  817. GSCM_status
  818. gscm_eval_file (char ** answer, GSCM_top_level toplvl, char * file_name)
  819. #else
  820. GSCM_status
  821. gscm_eval_file (answer, toplvl, file_name)
  822.      char ** answer;
  823.      GSCM_top_level toplvl;
  824.      char * file_name;
  825. #endif
  826. {
  827.   char command[MAXPATHLEN * 3];
  828.   format_load_command (command, file_name);
  829.   return gscm_eval_str (answer, toplvl, command);
  830. }
  831.  
  832.  
  833.  
  834.  
  835. /* {Error Messages}
  836.  */
  837.  
  838.  
  839. #ifdef __GNUC__
  840. # define AT(X)  [X] =
  841. #else
  842. # define AT(X)
  843. #endif 
  844.  
  845. static char * gscm_error_msgs[] =
  846. {
  847.   AT(GSCM_OK) "No error.",
  848.   AT(GSCM_QUIT) "QUIT executed.",
  849.   AT(GSCM_RESTART) "RESTART executed.",
  850.   AT(GSCM_ILLEGALLY_REENTERED) "Gscm function was illegally reentered.",
  851.   AT(GSCM_OUT_OF_MEM) "Out of memory.",
  852.   AT(GSCM_ERROR_OPENING_FILE) "Error opening file.",
  853.   AT(GSCM_ERROR_OPENING_INIT_FILE) "Error opening init file."
  854. };
  855.  
  856. #ifdef __STDC__
  857. char *
  858. gscm_error_msg (int n)
  859. #else
  860. char *
  861. gscm_error_msg (n)
  862.      int n;
  863. #endif
  864. {
  865.   if ((n < 0) || (n > (sizeof (gscm_error_msgs) / sizeof (char *))))
  866.     return "Unrecognized error.";
  867.   else
  868.     return gscm_error_msgs[n];
  869. }
  870.  
  871.  
  872.  
  873. /* {Defining New Procedures}
  874.  */
  875.  
  876. #ifdef __STDC__
  877. void
  878. gscm_define_procedure (char * name, SCM (*fn)(), int req, int opt, int varp, char * doc)
  879. #else
  880. void
  881. gscm_define_procedure (name, fn, req, opt, varp, doc)
  882.      char * name;
  883.      SCM (*fn)();
  884.      int req;
  885.      int opt;
  886.      int varp;
  887.      char * doc;
  888. #endif
  889. {
  890.   scm_make_gsubr (name, req, opt, varp, fn);
  891. }
  892.  
  893. #ifdef __STDC__
  894. SCM
  895. gscm_make_subr (SCM (*fn)(), int req, int opt, int varp, char * doc)
  896. #else
  897. SCM
  898. gscm_make_subr (fn, req, opt, varp, doc)
  899.      SCM (*fn)();
  900.      int req;
  901.      int opt;
  902.      int varp;
  903.      char * doc;
  904. #endif
  905. {
  906.   return scm_make_gsubr ("*anonymous*", req, opt, varp, fn);
  907. }
  908.  
  909. #define CURRY_PROC(cclo) (VELTS(cclo)[1])
  910. #define CURRY_ARG1(cclo) (VELTS(cclo)[2])
  911. static SCM curry_apply_fn;
  912.  
  913. #ifdef __STDC__
  914. static SCM 
  915. curry_apply (SCM self, SCM rest)
  916. #else
  917. static SCM 
  918. curry_apply (self, rest)
  919.      SCM self;
  920.      SCM rest;
  921. #endif
  922. {
  923.   return scm_apply (CURRY_PROC (self),
  924.             scm_cons (CURRY_ARG1 (self), rest),
  925.             EOL);
  926. }
  927.  
  928. #ifdef __STDC__
  929. SCM
  930. gscm_curry (SCM procedure, SCM first_arg)
  931. #else
  932. SCM
  933. gscm_curry (procedure, first_arg)
  934.      SCM procedure;
  935.      SCM first_arg;
  936. #endif
  937. {
  938.   SCM answer;
  939.  
  940.   answer = scm_makcclo (curry_apply_fn, 3L);
  941.   CURRY_ARG1(answer) = first_arg;
  942.   CURRY_PROC(answer) = procedure;
  943.   return answer;
  944. }
  945.  
  946.  
  947. #ifdef __STDC__
  948. int
  949. gscm_2_char (SCM c)
  950. #else
  951. int
  952. gscm_2_char (c)
  953.      SCM c;
  954. #endif
  955. {
  956.   ASSERT (ICHRP (c), c, ARG1, "gscm_2_char");
  957.   return ICHR (c);
  958. }
  959.  
  960.  
  961.  
  962. #ifdef __STDC__
  963. void
  964. gscm_2_str (char ** out, int * len_out, SCM * objp)
  965. #else
  966. void
  967. gscm_2_str (out, len_out, objp)
  968.      char ** out;
  969.      int * len_out;
  970.      SCM * objp;
  971. #endif
  972. {
  973.   ASSERT (NIMP (*objp) && STRINGP (*objp), *objp, ARG3, "gscm_2_str");
  974.   if (out)
  975.     *out = CHARS (*objp);
  976.   if (len_out)
  977.     *len_out = LENGTH (*objp);
  978. }
  979.  
  980.  
  981. #ifdef __STDC__
  982. void
  983. gscm_error (char * message, SCM args)
  984. #else
  985. void
  986. gscm_error (message, args)
  987.      char * message;
  988.      SCM args;
  989. #endif
  990. {
  991.   SCM errfn;
  992.   SCM str;
  993.  
  994.   errfn = CDR (scm_intern ("error", 5));
  995.   str = makfrom0str (message);
  996.   scm_apply (errfn, scm_cons (str, args), EOL);
  997. }
  998.  
  999.  
  1000. #define GSCM_SET_SIZE(OBJ, SIZE)    (CAR(OBJ) = (((SIZE) << 16) | tc16_gscm_obj))
  1001. #define GSCM_SIZE(OBJ)        ((CAR (OBJ) >> 16) & 0x7f)
  1002. #define GSCM_MEM(OBJ)        ((struct gscm_type **)CDR(OBJ))
  1003. #define GSCM_UMEM(OBJ)        ((char *)(1 + GSCM_MEM(OBJ)))
  1004. #define GSCM_UTYPE(OBJ)        (* GSCM_MEM(OBJ))
  1005.  
  1006. #ifdef __STDC__
  1007. static SCM
  1008. mark_gscm (SCM obj)
  1009. #else
  1010. static SCM
  1011. mark_gscm (obj)
  1012.      SCM obj;
  1013. #endif
  1014. {
  1015.   if (!GC8MARKP (obj))
  1016.     {
  1017.       STACKITEM * start;
  1018.       sizet size;
  1019.  
  1020.       SETGC8MARK (obj);
  1021.       start = (STACKITEM *)GSCM_UMEM (obj);
  1022.       size = ((GSCM_SIZE (obj) - sizeof (void *)) / sizeof (*start));
  1023.       scm_mark_locations (start, size);
  1024.     }
  1025.   return BOOL_F;
  1026. }
  1027.  
  1028. #ifdef __STDC__
  1029. static sizet
  1030. free_gscm (SCM obj)
  1031. #else
  1032. static sizet
  1033. free_gscm (obj)
  1034.      SCM obj;
  1035. #endif
  1036. {
  1037.   struct gscm_type * type;
  1038.  
  1039.   type = GSCM_UTYPE (obj);
  1040.   if (type->die)
  1041.     type->die (obj);
  1042.   {
  1043.     int size;
  1044.     size = GSCM_SIZE (obj);
  1045.     scm_must_free ((char *)GSCM_MEM (obj));
  1046.     return size;
  1047.   }
  1048. }
  1049.  
  1050. #ifdef __STDC__
  1051. static int
  1052. print_gscm (SCM exp, SCM port, int writingp)
  1053. #else
  1054. static int
  1055. print_gscm (exp, port, writingp)
  1056.      SCM exp;
  1057.      SCM port;
  1058.      int writingp;
  1059. #endif
  1060. {
  1061.   struct gscm_type * type;
  1062.  
  1063.   type = GSCM_UTYPE (exp);
  1064.   if (   !type->print
  1065.       || !(type->print (exp, port, writingp)))
  1066.     {
  1067.       scm_lputs ("#<", port);
  1068.       scm_lputs (type->name ? type->name : "unknown", port);
  1069.       scm_putc (' ', port);
  1070.       scm_intprint (exp, 16, port);
  1071.       scm_putc ('>', port);
  1072.     }
  1073.   return 1;
  1074. }
  1075.  
  1076. #ifdef __STDC__
  1077. static SCM
  1078. equal_gscm (SCM a, SCM b)
  1079. #else
  1080. static SCM
  1081. equal_gscm (a, b)
  1082.      SCM a;
  1083.      SCM b;
  1084. #endif
  1085. {
  1086.   struct gscm_type * type;
  1087.  
  1088.   if (a == b)
  1089.     return BOOL_T;
  1090.  
  1091.   type = GSCM_UTYPE (a);
  1092.   if (type != GSCM_UTYPE (b))
  1093.     return BOOL_F;
  1094.  
  1095.   if (type->equal)
  1096.     return (type->equal (a, b) ? BOOL_T: BOOL_F);
  1097.   else
  1098.     return BOOL_F;
  1099. }
  1100.  
  1101.  
  1102. static int tc16_gscm_obj;
  1103. static struct scm_smobfuns gscm_obj_smob
  1104. = { mark_gscm, free_gscm, print_gscm, equal_gscm };
  1105.  
  1106. #ifdef __STDC__
  1107. SCM
  1108. gscm_alloc (struct gscm_type * type, int size)
  1109. #else
  1110. SCM
  1111. gscm_alloc (type, size)
  1112.      struct gscm_type * type;
  1113.      int size;
  1114. #endif
  1115. {
  1116.   SCM answer;
  1117.   char * mem;
  1118.   
  1119.   size = 1 + ((size + sizeof (void *) - 1) / sizeof (void *));
  1120.   size *= sizeof (void *);
  1121.  
  1122.   NEWCELL (answer);
  1123.   DEFER_INTS;
  1124.   mem = (char *)scm_must_malloc (size, type->name);
  1125.   bzero (mem, size);
  1126.   CDR (answer) = (SCM)mem;
  1127.   GSCM_UTYPE (answer) = type;
  1128.   GSCM_SET_SIZE (answer, size);
  1129.   ALLOW_INTS;
  1130.   return answer;
  1131. }
  1132.      
  1133. #ifdef __STDC__
  1134. char *
  1135. gscm_unwrap_obj (struct gscm_type * type, SCM * objp)
  1136. #else
  1137. char *
  1138. gscm_unwrap_obj (type, objp)
  1139.      struct gscm_type * type;
  1140.      SCM * objp;
  1141. #endif
  1142. {
  1143.   SCM obj;
  1144.   obj = *objp;
  1145.   ASSERT (   NIMP (obj)
  1146.       && (TYP16 (obj) == tc16_gscm_obj)
  1147.       && (type == GSCM_UTYPE (obj)),
  1148.       obj, ARG2, "gscm_unwrap_obj");
  1149.  
  1150.   return GSCM_UMEM (obj);
  1151. }
  1152.  
  1153. #ifdef __STDC__
  1154. struct gscm_type * 
  1155. gscm_get_type (SCM * objp)
  1156. #else
  1157. struct gscm_type * 
  1158. gscm_get_type (objp)
  1159.      SCM * objp;
  1160. #endif
  1161. {
  1162.   SCM obj;
  1163.   obj = *objp;
  1164.   ASSERT (   NIMP (obj)
  1165.       && (TYP16 (obj) == tc16_gscm_obj),
  1166.       obj, ARG1, "gscm_get_type");
  1167.  
  1168.   return GSCM_UTYPE (obj);
  1169. }
  1170.  
  1171.  
  1172.  
  1173.  
  1174.  
  1175. static SCM
  1176. scm_stand_in_proc (proc)
  1177.      SCM proc;
  1178. {
  1179.   SCM answer;
  1180.   answer = scm_assoc (proc, scm_stand_in_procs);
  1181.   if (answer == BOOL_F)
  1182.     {
  1183.       answer = scm_closure (scm_listify (EOL, BOOL_F, SCM_UNDEFINED),
  1184.                 EOL);
  1185.       scm_stand_in_procs = scm_cons (scm_cons (proc, answer),
  1186.                      scm_stand_in_procs);
  1187.     }
  1188.   else
  1189.     answer = CDR (answer);
  1190.   return answer;
  1191. }
  1192.  
  1193. PROC (s_procedure_properties, "procedure-properties", 1, 0, 0, gscm_procedure_properties);
  1194. #ifdef __STDC__
  1195. SCM
  1196. gscm_procedure_properties (SCM proc)
  1197. #else
  1198. SCM
  1199. gscm_procedure_properties (proc)
  1200.      SCM proc;
  1201. #endif
  1202. {
  1203.   ASSERT (scm_procedure_p (proc), proc, ARG1, s_procedure_properties);
  1204.   if (!(NIMP (proc) && CLOSUREP (proc)))
  1205.     proc = scm_stand_in_proc (proc);
  1206.   return PROCPROPS (proc);
  1207. }
  1208.  
  1209. PROC (s_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, gscm_set_procedure_properties_x);
  1210. #ifdef __STDC__
  1211. SCM
  1212. gscm_set_procedure_properties_x (SCM proc, SCM new)
  1213. #else
  1214. SCM
  1215. gscm_set_procedure_properties_x (proc, new)
  1216.      SCM proc;
  1217.      SCM new;
  1218. #endif
  1219. {
  1220.   if (!(NIMP (proc) && CLOSUREP (proc)))
  1221.     proc = scm_stand_in_proc (proc);
  1222.   ASSERT (NIMP (proc) && CLOSUREP (proc), proc, ARG1, s_set_procedure_properties_x);
  1223.   PROCPROPS (proc) = new;
  1224.   return UNSPECIFIED;
  1225. }
  1226.  
  1227.  
  1228. PROC (s_procedure_assoc, "procedure-assoc", 2, 0, 0, gscm_procedure_assoc);
  1229. #ifdef __STDC__
  1230. SCM 
  1231. gscm_procedure_assoc (SCM p, SCM k)
  1232. #else
  1233. SCM 
  1234. gscm_procedure_assoc (p, k)
  1235.      SCM p;
  1236.      SCM k;
  1237. #endif
  1238. {
  1239.   if (!(NIMP (p) && CLOSUREP (p)))
  1240.     p = scm_stand_in_proc (p);
  1241.   ASSERT (scm_procedure_p (p), p, ARG1, s_procedure_assoc);
  1242.   return scm_assoc (k, PROCPROPS (p));
  1243. }
  1244.  
  1245. PROC (s_procedure_property, "procedure-property", 2, 0, 0, gscm_procedure_property);
  1246. #ifdef __STDC__
  1247. SCM
  1248. gscm_procedure_property (SCM p, SCM k)
  1249. #else
  1250. SCM
  1251. gscm_procedure_property (p, k)
  1252.      SCM p;
  1253.      SCM k;
  1254. #endif
  1255. {
  1256.   SCM assoc;
  1257.   if (!(NIMP (p) && CLOSUREP (p)))
  1258.     p = scm_stand_in_proc (p);
  1259.   ASSERT (scm_procedure_p (p), p, ARG1, s_procedure_property);
  1260.   assoc = scm_assoc (k, PROCPROPS (p));
  1261.   return (NIMP (assoc) ? CDR (assoc) : BOOL_F);
  1262. }
  1263.  
  1264. PROC (s_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, gscm_set_procedure_property_x);
  1265. #ifdef __STDC__
  1266. SCM
  1267. gscm_set_procedure_property_x (SCM p, SCM k, SCM v)
  1268. #else
  1269. SCM
  1270. gscm_set_procedure_property_x (p, k, v)
  1271.      SCM p;
  1272.      SCM k;
  1273.      SCM v;
  1274. #endif
  1275. {
  1276.   SCM assoc;
  1277.   if (!(NIMP (p) && CLOSUREP (p)))
  1278.     p = scm_stand_in_proc (p);
  1279.   ASSERT (NIMP (p) && CLOSUREP (p), p, ARG1, s_set_procedure_property_x);
  1280.   assoc = scm_assoc (k, PROCPROPS (p));
  1281.   if (NIMP (assoc))
  1282.     SETCDR (assoc, v);
  1283.   else
  1284.     PROCPROPS (p) = scm_acons (k, v, PROCPROPS (p));
  1285.   return UNSPECIFIED;
  1286. }
  1287.  
  1288.  
  1289. #ifdef __STDC__
  1290. GSCM_status
  1291. guile_ks (void)
  1292. #else
  1293. GSCM_status
  1294. guile_ks ()
  1295. #endif
  1296. {
  1297.   return 0;
  1298. }
  1299.  
  1300.  
  1301. #ifdef __STDC__
  1302. GSCM_status
  1303. gscm_run_scm (int argc, char ** argv, FILE * in, FILE * out, FILE * err, GSCM_status (*initfn)(), char * initfile, char * initcmd)
  1304. #else
  1305. GSCM_status
  1306. gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd)
  1307.      int argc;
  1308.      char ** argv;
  1309.      FILE * in;
  1310.      FILE * out;
  1311.      FILE * err;
  1312.      GSCM_status (*initfn)();
  1313.      char * initfile;
  1314.      char * initcmd;
  1315. #endif
  1316. {
  1317.   SCM_STACKITEM i;
  1318.   GSCM_status status;
  1319.   GSCM_top_level top;
  1320.  
  1321.   scm_ports_prehistory ();
  1322.   scm_smob_prehistory ();
  1323.   scm_tables_prehistory ();
  1324.   scm_init_storage (&i, init_heap_size, in, out, err);    /* BASE (rootcont) gets set here */
  1325.   scm_init_gsubr ();
  1326.   scm_init_arbiters ();
  1327.   scm_init_boolean ();
  1328.   scm_init_chars ();
  1329.   scm_init_continuations ();
  1330.   scm_init_dynwind ();
  1331.   scm_init_eq ();
  1332.   scm_init_error ();
  1333.   scm_init_feature ();
  1334.   scm_init_fports ();
  1335.   scm_init_files ();
  1336.   scm_init_gc ();
  1337.   scm_init_hash ();
  1338.   scm_init_kw ();
  1339.   scm_init_lvectors ();
  1340.   scm_init_numbers ();
  1341.   scm_init_pairs ();
  1342.   scm_init_ports ();
  1343.   scm_init_procs ();
  1344.   scm_init_record ();
  1345.   scm_init_repl (gscm_default_verbosity);
  1346.   scm_init_scmsigs ();
  1347.   scm_init_stackchk ();
  1348.   scm_init_strports ();
  1349.   scm_init_struct ();
  1350.   scm_init_symbols ();
  1351.   scm_init_time ();
  1352.   scm_init_strings ();
  1353.   scm_init_strop ();
  1354.   scm_init_throw ();
  1355.   scm_init_variable ();
  1356.   scm_init_vectors ();
  1357.   scm_init_vports ();
  1358.   scm_init_eval ();
  1359.   scm_init_ramap ();
  1360.   scm_init_unif ();
  1361.   scm_init_simpos ();
  1362.   scm_init_guile ();
  1363.   initfn ();
  1364.  
  1365.   /* Save the argument list to be the return value of (program-arguments).
  1366.    */
  1367.   progargs = scm_makfromstrs (argc, argv);
  1368.  
  1369.   scm_exitval = MAKINUM (EXIT_SUCCESS);
  1370.   scm_errjmp_bad = 0;
  1371.   errno = 0;
  1372.   scm_alrm_deferred = 0;
  1373.   scm_sig_deferred = 0;
  1374.   scm_ints_disabled = 1;
  1375.  
  1376.   if (initfile == NULL)
  1377.     {
  1378.       initfile = getenv ("SCM_INIT_PATH");
  1379.       if (initfile == NULL)
  1380.     initfile = IMPLINIT;
  1381.     }
  1382.  
  1383.   if (initfile == NULL)
  1384.     {
  1385.       init_file_processed = 1;
  1386.       status = GSCM_OK;
  1387.     }
  1388.   else
  1389.     {
  1390.       int verb;
  1391.       SCM answer;
  1392.  
  1393.       gscm_last_attempted_init_file = initfile;
  1394.       verb = scm_verbose;
  1395.       scm_verbose = -1;
  1396.       init_file_processed = 0;
  1397.       strncpy (init_file_name, initfile, MAXPATHLEN);
  1398.       status = gscm_seval_file (&answer, -1, initfile);
  1399.       if ((status == GSCM_OK) && (answer == BOOL_F))
  1400.     status = GSCM_ERROR_OPENING_INIT_FILE;
  1401.       scm_verbose = verb;
  1402.     }
  1403.  
  1404.   if (status == GSCM_OK)
  1405.     status = gscm_create_top_level (&top);
  1406.  
  1407.   if (status == GSCM_OK)
  1408.     {
  1409.       scm_verbose = -1;
  1410.       status = gscm_seval_str (0, top, initcmd);
  1411.     }
  1412.   return status;
  1413. }
  1414.  
  1415.  
  1416.  
  1417. #ifdef __STDC__
  1418. SCM
  1419. gscm_malloc_2_uve (int type, int k, int size, char * data)
  1420. #else
  1421. SCM
  1422. gscm_malloc_2_uve (type, k, size, data)
  1423.      int type;
  1424.      int k;
  1425.      int size;
  1426.      char * data;
  1427. #endif
  1428. {
  1429.   SCM v;
  1430.   NEWCELL (v);
  1431.   DEFER_INTS;
  1432.   scm_mallocated += size;
  1433.   SETCHARS (v, data);
  1434.   SETLENGTH (v, (k < LENGTH_MAX ? k : LENGTH_MAX), type);
  1435.   ALLOW_INTS;
  1436.   return v;
  1437. }
  1438.  
  1439.  
  1440.  
  1441.  
  1442. #ifdef __STDC__
  1443. int
  1444. gscm_is_gscm_obj (SCM obj)
  1445. #else
  1446. int
  1447. gscm_is_gscm_obj (obj)
  1448.      SCM obj;
  1449. #endif
  1450. {
  1451.   return (NIMP (obj) && TYP16 (obj) == tc16_gscm_obj);
  1452. }
  1453.  
  1454.  
  1455.  
  1456.  
  1457.  
  1458. void
  1459. scm_init_guile ()
  1460. {
  1461.   curry_apply_fn = scm_make_gsubr (" curry-apply", 0, 0, 1, curry_apply);
  1462.   tc16_gscm_obj = scm_newsmob (&gscm_obj_smob);
  1463. #include "gscm.x"
  1464. }
  1465.  
  1466.